home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / cache.lsp < prev    next >
Encoding:
Text File  |  1992-09-09  |  58.5 KB  |  1,601 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws. 
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The basics of the PCL wrapper cache mechanism.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31. ;;;
  32. ;;; The caching algorithm implemented:
  33. ;;;
  34. ;;; << put a paper here >>
  35. ;;;
  36. ;;; For now, understand that as far as most of this code goes, a cache has
  37. ;;; two important properties.  The first is the number of wrappers used as
  38. ;;; keys in each cache line.  Throughout this code, this value is always
  39. ;;; called NKEYS.  The second is whether or not the cache lines of a cache
  40. ;;; store a value.  Throughout this code, this always called VALUEP.
  41. ;;;
  42. ;;; Depending on these values, there are three kinds of caches.
  43. ;;;
  44. ;;; NKEYS = 1, VALUEP = NIL
  45. ;;;
  46. ;;; In this kind of cache, each line is 1 word long.  No cache locking is
  47. ;;; needed since all read's in the cache are a single value.  Nevertheless
  48. ;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
  49. ;;; not get a first probe hit.
  50. ;;;
  51. ;;; To keep the code simpler, a cache lock count does appear in location 0
  52. ;;; of these caches, that count is incremented whenever data is written to
  53. ;;; the cache.  But, the actual lookup code (see make-dlap) doesn't need to
  54. ;;; do locking when reading the cache.
  55. ;;; 
  56. ;;;
  57. ;;; NKEYS = 1, VALUEP = T
  58. ;;;
  59. ;;; In this kind of cache, each line is 2 words long.  Cache locking must
  60. ;;; be done to ensure the synchronization of cache reads.  Line 0 of the
  61. ;;; cache (location 0) is reserved for the cache lock count.  Location 1
  62. ;;; of the cache is unused (in effect wasted).
  63. ;;; 
  64. ;;; NKEYS > 1
  65. ;;;
  66. ;;; In this kind of cache, the 0 word of the cache holds the lock count.
  67. ;;; The 1 word of the cache is line 0.  Line 0 of these caches is not
  68. ;;; reserved.
  69. ;;;
  70. ;;; This is done because in this sort of cache, the overhead of doing the
  71. ;;; cache probe is high enough that the 1+ required to offset the location
  72. ;;; is not a significant cost.  In addition, because of the larger line
  73. ;;; sizes, the space that would be wasted by reserving line 0 to hold the
  74. ;;; lock count is more significant.
  75. ;;;
  76.  
  77. (declaim (ftype (function () index)
  78.         get-wrapper-cache-number))
  79. (declaim (ftype (function (T T T) (values index index index index))
  80.                 compute-cache-parameters))
  81. (declaim (ftype (function (T T T) index)
  82.         compute-primary-cache-location
  83.         compute-primary-cache-location-from-location))
  84. (declaim (ftype (function (T) index)
  85.         cache-count))
  86. (declaim (ftype (function (T T T T) boolean)
  87.         fill-cache-p
  88.         fill-cache-from-cache-p))
  89. (declaim (ftype (function (T T &optional T) (values T boolean))
  90.         find-free-cache-line))
  91. (declaim (ftype (function (index) index)
  92.         compute-line-size
  93.         default-limit-fn
  94.         power-of-two-ceiling))
  95. (declaim (ftype (function (T) boolean)
  96.         free-cache-vector))
  97.  
  98.  
  99. ;;;
  100. ;;; Caches
  101. ;;;
  102. ;;; A cache is essentially just a vector.  The use of the individual `words'
  103. ;;; in the vector depends on particular properties of the cache as described
  104. ;;; above.
  105. ;;;
  106. ;;; This defines an abstraction for caches in terms of their most obvious
  107. ;;; implementation as simple vectors.  But, please notice that part of the
  108. ;;; implementation of this abstraction, is the function lap-out-cache-ref.
  109. ;;; This means that most port-specific modifications to the implementation
  110. ;;; of caches will require corresponding port-specific modifications to the
  111. ;;; lap code assembler.
  112. ;;;
  113. (defmacro cache-vector-ref (cache-vector location)
  114.   `(svref (the simple-vector ,cache-vector)
  115.           (#-cmu the #+cmu ext:truly-the fixnum ,location)))
  116.  
  117. (defun emit-cache-vector-ref (cache-vector-operand location-operand)
  118.   (operand :iref cache-vector-operand location-operand))
  119.  
  120.  
  121. (defmacro cache-vector-size (cache-vector)
  122.   `(array-dimension (the simple-vector ,cache-vector) 0))
  123.  
  124. (defun allocate-cache-vector (size)
  125.   (declare (type index size))
  126.   (make-array size :adjustable nil))
  127.  
  128. (defmacro cache-vector-lock-count (cache-vector)
  129.   `(cache-vector-ref ,cache-vector 0))
  130.  
  131. (defun flush-cache-vector-internal (cache-vector)
  132.   (without-interrupts-simple
  133.     (fill (the simple-vector cache-vector) nil)
  134.     (setf (cache-vector-lock-count cache-vector) 0))
  135.   cache-vector)
  136.  
  137. (defmacro modify-cache (cache-vector &body body)
  138.   `(without-interrupts-simple
  139.      (multiple-value-prog1
  140.        (progn ,@body)
  141.        (let ((old-count (cache-vector-lock-count ,cache-vector)))
  142.      (declare (type index old-count))
  143.      (setf (cache-vector-lock-count ,cache-vector)
  144.                (the index
  145.                 (if (= old-count most-positive-fixnum)
  146.                 1
  147.                         (the index (1+ old-count)))))))))
  148.  
  149. (deftype field-type ()
  150.   '(integer 0    ;#.(position 'number wrapper-layout)
  151.             7))  ;#.(position 'number wrapper-layout :from-end t)
  152.  
  153. (eval-when (compile load eval)
  154. (defun power-of-two-ceiling (x)
  155.   (declare (type index x))
  156.   ;;(expt 2 (ceiling (log x 2)))
  157.   (the index (ash 1 (integer-length (1- x)))))
  158.  
  159. (defconstant *nkeys-limit* 256)
  160. )
  161.  
  162. (defstruct (cache
  163.          (:print-function print-cache)
  164.          (:constructor make-cache ())
  165.          (:copier copy-cache-internal))
  166.   (nkeys 1 :type (integer 1 #.*nkeys-limit*))
  167.   (valuep nil :type boolean)
  168.   (nlines 0 :type index)
  169.   (field 0 :type field-type)
  170.   (limit-fn #'default-limit-fn :type real-function)
  171.   (mask 0 :type index)
  172.   (size 0 :type index)
  173.   (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*))))
  174.   (max-location 0 :type index)
  175.   (vector '#() :type simple-vector)
  176.   (overflow nil :type list))
  177.  
  178. (defun print-cache (cache stream depth)
  179.   (declare (ignore depth))
  180.   (printing-random-thing (cache stream)
  181.     (format stream "cache ~D ~S ~D" 
  182.         (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache))))
  183.  
  184. #+akcl
  185. (si::freeze-defstruct 'cache)
  186.  
  187. (defmacro cache-lock-count (cache)
  188.   `(cache-vector-lock-count (cache-vector ,cache)))
  189.  
  190.  
  191. ;;;
  192. ;;; Some facilities for allocation and freeing caches as they are needed.
  193. ;;; This is done on the assumption that a better port of PCL will arrange
  194. ;;; to cons these all the same static area.  Given that, the fact that
  195. ;;; PCL tries to reuse them should be a win.
  196. ;;; 
  197. (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
  198.  
  199. ;;;
  200. ;;; Return a cache that has had flush-cache-internal called on it.  This
  201. ;;; returns a cache of exactly the size requested, it won't ever return a
  202. ;;; larger cache.
  203. ;;; 
  204. (defun get-cache-vector (size)
  205.   (let ((entry (gethash size *free-cache-vectors*)))
  206.     (without-interrupts-simple
  207.       (cond ((null entry)
  208.          (setf (gethash size *free-cache-vectors*) (cons 0 nil))
  209.          (get-cache-vector size))
  210.         ((null (cdr entry))
  211.              (setf (car entry) (the fixnum (1+ (the fixnum (car entry)))))
  212.          (flush-cache-vector-internal (allocate-cache-vector size)))
  213.         (t
  214.          (let ((cache (cdr entry)))
  215.            (setf (cdr entry) (cache-vector-ref cache 0))
  216.            (flush-cache-vector-internal cache)))))))
  217.  
  218. (defun free-cache-vector (cache-vector)
  219.   (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
  220.     (without-interrupts-simple
  221.       (if (null entry)
  222.       (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.")
  223.       (let ((thread (cdr entry)))
  224.         (loop (unless thread (return))
  225.           (when (eq thread cache-vector) (error "Freeing a cache twice."))
  226.           (setq thread (cache-vector-ref thread 0)))      
  227.         (flush-cache-vector-internal cache-vector)        ;Help the GC
  228.         (setf (cache-vector-ref cache-vector 0) (cdr entry))
  229.         (setf (cdr entry) cache-vector)
  230.         nil)))))
  231.  
  232. ;;;
  233. ;;; This is just for debugging and analysis.  It shows the state of the free
  234. ;;; cache resource.
  235. ;;; 
  236. (defun show-free-cache-vectors ()
  237.   (let ((elements ()))
  238.     (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
  239.     (setq elements (sort elements #'< :key #'car))
  240.     (dolist (e elements)
  241.       (let* ((size (car e))
  242.          (entry (cadr e))
  243.          (allocated (car entry))
  244.          (head (cdr entry))
  245.          (free 0))
  246.         (declare (type index allocated free))
  247.     (loop (when (null head) (return t))
  248.           (setq head (cache-vector-ref head 0))
  249.           (incf free))
  250.     (format t
  251.         "~&There  ~4D are caches of size ~4D. (~D free  ~3D%)"
  252.         allocated
  253.         size
  254.         free
  255.         (floor (* 100 (/ free (float allocated)))))))))
  256.  
  257.  
  258. ;;;
  259. ;;; Wrapper cache numbers
  260. ;;; 
  261.  
  262. ;;;
  263. ;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero
  264. ;;; bits wrapper cache numbers will have.
  265. ;;;
  266. ;;; The value of this constant is the number of wrapper cache numbers which
  267. ;;; can be added and still be certain the result will be a fixnum.  This is
  268. ;;; used by all the code that computes primary cache locations from multiple
  269. ;;; wrappers.
  270. ;;;
  271. ;;; The value of this constant is used to derive the next two which are the
  272. ;;; forms of this constant which it is more convenient for the runtime code
  273. ;;; to use.
  274. ;;; 
  275. (eval-when (compile load eval)
  276.  
  277. (defconstant wrapper-cache-number-adds-ok 4)
  278.  
  279. (defconstant wrapper-cache-number-length
  280.          (- (integer-length most-positive-fixnum)
  281.         wrapper-cache-number-adds-ok))
  282.  
  283. (defconstant wrapper-cache-number-mask
  284.          (1- (expt 2 wrapper-cache-number-length)))
  285.  
  286. (defvar *get-wrapper-cache-number* (make-random-state))
  287.  
  288. (defun get-wrapper-cache-number ()
  289.   (let ((n 0))
  290.     (declare (type index n))
  291.     (loop
  292.       (setq n
  293.         (logand (the index wrapper-cache-number-mask)
  294.             (the index (random most-positive-fixnum
  295.                                        *get-wrapper-cache-number*))))
  296.       (unless (zerop n) (return n)))))
  297.  
  298.  
  299. (unless (> wrapper-cache-number-length 8)
  300.   (error "In this implementation of Common Lisp, fixnums are so small that~@
  301.           wrapper cache numbers end up being only ~D bits long.  This does~@
  302.           not actually keep PCL from running, but it may degrade cache~@
  303.           performance.~@
  304.           You may want to consider changing the value of the constant~@
  305.           WRAPPER-CACHE-NUMBER-ADDS-OK.")))
  306.  
  307.  
  308. ;;;
  309. ;;; wrappers themselves
  310. ;;;
  311. ;;; This caching algorithm requires that wrappers have more than one wrapper
  312. ;;; cache number.  You should think of these multiple numbers as being in
  313. ;;; columns.  That is, for a given cache, the same column of wrapper cache
  314. ;;; numbers will be used.
  315. ;;;
  316. ;;; If at some point the cache distribution of a cache gets bad, the cache
  317. ;;; can be rehashed by switching to a different column.
  318. ;;;
  319. ;;; The columns are referred to by field number which is that number which,
  320. ;;; when used as a second argument to wrapper-ref, will return that column
  321. ;;; of wrapper cache number.
  322. ;;;
  323. ;;; This code is written to allow flexibility as to how many wrapper cache
  324. ;;; numbers will be in each wrapper, and where they will be located.  It is
  325. ;;; also set up to allow port specific modifications to `pack' the wrapper
  326. ;;; cache numbers on machines where the addressing modes make that a good
  327. ;;; idea.
  328. ;;; 
  329. ;;; For July 92, the wrapper field UNRESERVED-FIELD, accessable by macro
  330. ;;; WRAPPER-UNRESERVED-FIELD, has been created to allow a programmer to
  331. ;;; store his own items in the wrapper if so desired.  (Since there is
  332. ;;; only one wrapper per class, this could be added at minimal cost).
  333. ;;; It would be nice for this kind of low level hook to be part of the
  334. ;;; MOP.  -- TL.
  335.  
  336. (defconstant *temporary-static-slot-storage-copy* (make-array 1))
  337.  
  338. #-structure-wrapper
  339. (eval-when (compile load eval)
  340. (defconstant wrapper-layout
  341.          '(number
  342.            number
  343.            number
  344.            number
  345.            number
  346.            number
  347.            number
  348.            number
  349.                wrapper-identifier
  350.            state
  351.            instance-slots-layout
  352.            class-slots
  353.            class
  354.            class-precedence-list
  355.                allocate-static-slot-storage-copy
  356.                unreserved-field))
  357.  
  358. (defconstant wrapper-length 16)          ; #.(length wrapper-layout)
  359.  
  360. (deftype wrapper () `(simple-vector 16)) ; #.(length wrapper-layout)
  361. )
  362.  
  363. #-structure-wrapper
  364. (progn
  365.  
  366. (eval-when (compile load eval)
  367.  
  368. (declaim (ftype (function (T) index) wrapper-field))
  369. (defun wrapper-field (type)
  370.   (posq type wrapper-layout))
  371.  
  372. (declaim (ftype (function (index) (or index null)) next-wrapper-field))
  373. (defun next-wrapper-field (field-number)
  374.   (declare (type index field-number))
  375.   (position (nth field-number wrapper-layout)
  376.         wrapper-layout
  377.         :start (1+ field-number)))
  378.  
  379. (defmacro first-wrapper-cache-number-index ()
  380.   `(the field-type (wrapper-field 'number)))
  381.  
  382. (defmacro next-wrapper-cache-number-index (field-number)
  383.   `(next-wrapper-field ,field-number))
  384.  
  385. );eval-when
  386.  
  387. (defmacro wrapper-cache-number-vector (wrapper)
  388.   wrapper)
  389.  
  390. (defmacro cache-number-vector-ref (cnv n)
  391.   `(svref ,cnv ,n))
  392.  
  393. (defconstant *wrapper-identifier-symbol* (gensym "WRAPPER-IDENTIFIER"))
  394.  
  395. (defmacro wrapper-ref (wrapper n)
  396.   `(svref (the wrapper ,wrapper) (the index ,n)))
  397.  
  398. (defun emit-wrapper-ref (wrapper-operand field-operand)
  399.   (operand :iref wrapper-operand field-operand))
  400.  
  401.  
  402. (defmacro wrapper-p (x)
  403.   (once-only (x)
  404.     `(locally (declare #.*optimize-speed*)
  405.        (and (simple-vector-p ,x)
  406.             (= (the index (length (the simple-vector ,x)))
  407.                wrapper-length)
  408.             (eq (wrapper-ref ,x ,(wrapper-field 'wrapper-identifier))
  409.                 *wrapper-identifier-symbol*)))))
  410.  
  411. (defmacro wrapper-state (wrapper)
  412.   `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
  413.  
  414. (defmacro wrapper-instance-slots-layout (wrapper)
  415.   `(the list
  416.         (wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))))
  417.  
  418. (defmacro wrapper-class-slots (wrapper)
  419.   `(the list
  420.         (wrapper-ref ,wrapper ,(wrapper-field 'class-slots))))
  421.  
  422. (defmacro wrapper-class (wrapper)
  423.   `(wrapper-ref ,wrapper ,(wrapper-field 'class)))
  424.  
  425. (defmacro wrapper-class-precedence-list (wrapper)
  426.   `(the list
  427.         (wrapper-ref ,wrapper ,(wrapper-field 'class-precedence-list))))
  428.  
  429. (defmacro wrapper-allocate-static-slot-storage-copy (wrapper)
  430.   `(the simple-vector
  431.         (wrapper-ref ,wrapper ,(wrapper-field 'allocate-static-slot-storage-copy))))
  432.  
  433. (defmacro wrapper-unreserved-field (wrapper)
  434.   "Field unreserved by PCL.  May be used by user programs."
  435.   `(wrapper-ref ,wrapper ,(wrapper-field 'unreserved-field)))
  436.  
  437.  
  438. (defmacro make-wrapper-internal ()
  439.   `(let ((wrapper
  440.            (make-array ,(length (the list wrapper-layout)) :adjustable nil)))
  441.      (declare (type wrapper wrapper))
  442.      ,@(gathering1 (collecting)
  443.      (iterate ((i (interval :from 0))
  444.            (desc (list-elements wrapper-layout)))
  445.        (ecase desc
  446.              (wrapper-identifier
  447.               (gather1 `(setf (wrapper-ref wrapper ,i)
  448.                               *wrapper-identifier-symbol*)))
  449.          (number
  450.           (gather1 `(setf (wrapper-ref wrapper ,i)
  451.                   (the index (get-wrapper-cache-number)))))
  452.              (allocate-static-slot-storage-copy
  453.               (gather1 `(setf (wrapper-ref wrapper ,i)
  454.                               *temporary-static-slot-storage-copy*)))
  455.          ((state instance-slots-layout class-slots class 
  456.                class-precedence-list unreserved-field)))))
  457.      (setf (wrapper-state wrapper) 't)
  458.      wrapper))
  459.  
  460. (defun make-wrapper (class)
  461.   (let ((wrapper (make-wrapper-internal)))
  462.     (setf (wrapper-class wrapper) class)
  463.     wrapper))
  464.  
  465. ) ;#-structure-wrapper
  466.  
  467.  
  468. ; In CMUCL we want to do type checking as early as possible; structures help this.
  469. #+structure-wrapper
  470. (eval-when (compile load eval)
  471.  
  472. (defconstant wrapper-cache-number-vector-length 8)
  473.  
  474. (deftype cache-number-vector ()
  475.   `(simple-array fixnum (8)))
  476.  
  477. (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
  478.                        :initial-element 'number))
  479.  
  480. )
  481.  
  482. #+structure-wrapper
  483. (progn
  484.  
  485. (defun make-wrapper-cache-number-vector ()
  486.   (let ((cnv (make-array wrapper-cache-number-vector-length)))
  487.     (dotimes (i #.wrapper-cache-number-vector-length)
  488.       (setf (svref cnv i) (get-wrapper-cache-number)))
  489.     cnv))
  490.  
  491. (defstruct (wrapper
  492.          (:print-function print-wrapper)
  493.          (:constructor make-wrapper (class)))
  494.   (cache-number-vector (make-wrapper-cache-number-vector)
  495.                :type cache-number-vector)
  496.   (state t :type (or (member t) cons)) ; a cons whose car is one of: flush or obsolete
  497.   (instance-slots-layout nil :type list)
  498.   (class-slots nil :type list)
  499.   (class *the-class-t* :type class)
  500.   (class-precedence-list nil :type list)
  501.   (allocate-static-slot-storage-copy *temporary-static-slot-storage-copy*
  502.                                      :type simple-vector)
  503.   (unreserved-field nil))
  504.  
  505. #+akcl
  506. (si::freeze-defstruct 'cache)
  507.  
  508. (defun print-wrapper (wrapper stream depth)
  509.   (declare (ignore depth))
  510.   (printing-random-thing (wrapper stream)
  511.     (format stream "wrapper ~S" (wrapper-class wrapper))))
  512.  
  513. (defmacro first-wrapper-cache-number-index ()
  514.   0)
  515.  
  516. (defmacro next-wrapper-cache-number-index (field-number)
  517.   `(and (< (the index ,field-number) #.(1- wrapper-cache-number-vector-length))
  518.         (1+ (the index ,field-number))))
  519.  
  520. (defmacro cache-number-vector-ref (cnv n)
  521.   `(svref ,cnv ,n))
  522.  
  523. (defun emit-wrapper-cache-number-vector (wrapper-operand)
  524.   (operand :wrapper-cache-number-vector wrapper-operand))
  525.  
  526. (defun emit-cache-number-vector-ref (cnv-operand field-operand)
  527.   (operand :iref cnv-operand field-operand))
  528.  
  529. ) ;#+structure-wrapper
  530.  
  531. (defmacro wrapper-cache-number-vector-ref (wrapper n)
  532.   `(svref (wrapper-cache-number-vector ,wrapper) ,n))
  533.  
  534.  
  535. ;;;
  536. ;;;
  537. ;;;
  538.  
  539. (defvar *built-in-or-structure-wrapper-table*
  540.   (make-hash-table :test 'eq))
  541.  
  542. (defvar wft-type1 nil)
  543. (defvar wft-wrapper1 nil)
  544. (defvar wft-type2 nil)
  545. (defvar wft-wrapper2 nil)
  546.  
  547. (defun wrapper-for-structure (x)
  548.   (let ((type (structure-type x)))
  549.     (when (symbolp type)
  550.       (cond ((eq type wft-type1)
  551.              (return-from wrapper-for-structure wft-wrapper1))
  552.             ((eq type wft-type2)
  553.              (return-from wrapper-for-structure wft-wrapper2))
  554.             (t (setq wft-type2 wft-type1  wft-wrapper2 wft-wrapper1))))
  555.     (let* ((cell (find-class-cell type))
  556.            (class (or (find-class-cell-class cell)
  557.                       (let* (#+lucid
  558.                              (*structure-type* type)
  559.                              #+lucid
  560.                              (*structure-length* (structure-length x type)))
  561.                         (find-class-from-cell type cell nil))))
  562.            (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))
  563.      (when (symbolp type)
  564.         (setq wft-type1 type  wft-wrapper1 wrapper))
  565.       wrapper)))
  566.  
  567. (defmacro built-in-or-structure-wrapper (x)
  568.   (once-only (x)
  569.     `(if (structurep ,x)
  570.          (wrapper-for-structure ,x)
  571.          (if (symbolp ,x)
  572.          (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
  573.          (built-in-wrapper-of ,x)))))
  574.  
  575. (defun built-in-or-structure-wrapper-fun (x)
  576.   (built-in-or-structure-wrapper x))
  577.  
  578. (defmacro fast-wrapper-of (x)
  579.   (once-only (x)
  580.     `(cond ((std-instance-p ,x)
  581.         (std-instance-wrapper ,x))
  582.            ((fsc-instance-p ,x)
  583.         (fsc-instance-wrapper ,x))
  584.            #+pcl-user-instances
  585.            ((get-user-instance-p ,x)
  586.         (get-user-instance-wrapper ,x))
  587.            (T (built-in-or-structure-wrapper ,x)))))
  588.  
  589. ;;;
  590. ;;; The wrapper cache machinery provides general mechanism for trapping on
  591. ;;; the next access to any instance of a given class.  This mechanism is
  592. ;;; used to implement the updating of instances when the class is redefined
  593. ;;; (make-instances-obsolete).  The same mechanism is also used to update
  594. ;;; generic function caches when there is a change to the supers of a class.
  595. ;;;
  596. ;;; Basically, a given wrapper can be valid or invalid.  If it is invalid,
  597. ;;; it means that any attempt to do a wrapper cache lookup using the wrapper
  598. ;;; should trap.  Also, methods on slot-value-using-class check the wrapper
  599. ;;; validity as well.  This is done by calling check-wrapper-validity.
  600. ;;; 
  601.  
  602. (defmacro invalid-wrapper-p (wrapper)
  603.   `(neq (wrapper-state ,wrapper) 't))
  604.  
  605. (defvar *previous-nwrappers* (make-hash-table))
  606.  
  607. (defun invalidate-wrapper (owrapper state nwrapper)
  608.   (ecase state
  609.     ((flush obsolete)
  610.      (let ((new-previous ()))
  611.        ;;
  612.        ;; First off, a previous call to invalidate-wrapper may have recorded
  613.        ;; owrapper as an nwrapper to update to.  Since owrapper is about to
  614.        ;; be invalid, it no longer makes sense to update to it.
  615.        ;;
  616.        ;; We go back and change the previously invalidated wrappers so that
  617.        ;; they will now update directly to nwrapper.  This corresponds to a
  618.        ;; kind of transitivity of wrapper updates.
  619.        ;; 
  620.        (dolist (previous (gethash owrapper *previous-nwrappers*))
  621.      (when (eq state 'obsolete)
  622.        (setf (car previous) 'obsolete))
  623.      (setf (cadr previous) nwrapper)
  624.      (push previous new-previous))
  625.        
  626.        (let ((ocnv (wrapper-cache-number-vector owrapper)))
  627.      (iterate ((type (list-elements wrapper-layout))
  628.            (i (interval :from 0)))
  629.            (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0))))
  630.        (push (setf (wrapper-state owrapper) (list state nwrapper))
  631.          new-previous)
  632.        
  633.        (setf (gethash owrapper *previous-nwrappers*) ()
  634.          (gethash nwrapper *previous-nwrappers*) new-previous)))))
  635.  
  636. (defun wrapper-state-trap (wrapper object)
  637.   (let ((state (wrapper-state wrapper)))
  638.     (ecase (car state)
  639.       (flush
  640.         (flush-cache-trap wrapper (cadr state) object))
  641.       (obsolete
  642.         (obsolete-instance-trap wrapper (cadr state) object)))))
  643.  
  644. (defmacro fast-check-wrapper-validity (object
  645.                                        &optional (wrapper-fn 'fast-wrapper-of))
  646.   (let ((owrapper (gensym "OWRAPPER")))
  647.     (once-only (object)
  648.       `(let ((,owrapper (,wrapper-fn ,object)))
  649.          (if (eq 't (wrapper-state ,owrapper))
  650.          ,owrapper
  651.          (wrapper-state-trap ,owrapper ,object))))))
  652.  
  653. (defun check-wrapper-validity (instance)
  654.   (fast-check-wrapper-validity instance wrapper-of))
  655.  
  656.  
  657.  
  658.  
  659. (defvar *free-caches* nil)
  660.  
  661. (defun get-cache (nkeys valuep limit-fn nlines)
  662.   (declare (type index         nkeys)
  663.            (type boolean       valuep)
  664.            (type real-function limit-fn)
  665.            (type index         nlines))
  666.   (let ((cache (or (without-interrupts-simple (pop *free-caches*))
  667.                    (make-cache))))
  668.     (declare (type cache cache))
  669.     (multiple-value-bind (cache-mask actual-size line-size nlines)
  670.     (compute-cache-parameters nkeys valuep nlines)
  671.       (declare (type index cache-mask actual-size line-size nlines))
  672.       (setf (cache-nkeys cache) nkeys
  673.         (cache-valuep cache) valuep
  674.         (cache-nlines cache) nlines
  675.         (cache-field cache) (first-wrapper-cache-number-index)
  676.         (cache-limit-fn cache) limit-fn
  677.         (cache-mask cache) cache-mask
  678.         (cache-size cache) actual-size
  679.         (cache-line-size cache) line-size
  680.         (cache-max-location cache)
  681.               (the index (let ((line (1- nlines)))
  682.                             (declare (type index line))
  683.                 (if (= nkeys 1)
  684.                     (the index (* line line-size))
  685.                     (the index (1+ (the index (* line line-size)))))))
  686.         (cache-vector cache) (get-cache-vector actual-size)
  687.         (cache-overflow cache) nil)
  688.       cache)))
  689.  
  690. (defun get-cache-from-cache (old-cache new-nlines 
  691.                  &optional (new-field (first-wrapper-cache-number-index)))
  692.   (declare (type index new-nlines) (type field-type new-field))
  693.   (let ((nkeys (cache-nkeys old-cache))
  694.     (valuep (cache-valuep old-cache))
  695.     (cache (or (without-interrupts-simple (pop *free-caches*))
  696.                    (make-cache))))
  697.     (declare (type cache cache) (type index nkeys)
  698.              (type boolean valuep))
  699.     (multiple-value-bind (cache-mask actual-size line-size nlines)
  700.     (if (= new-nlines (cache-nlines old-cache))
  701.         (values (cache-mask old-cache) (cache-size old-cache) 
  702.             (cache-line-size old-cache) (cache-nlines old-cache))
  703.         (compute-cache-parameters nkeys valuep new-nlines))
  704.       (declare (type index cache-mask actual-size line-size nlines))
  705.       (setf (cache-nkeys cache) nkeys
  706.         (cache-valuep cache) valuep
  707.         (cache-nlines cache) nlines
  708.         (cache-field cache) new-field
  709.         (cache-limit-fn cache) (cache-limit-fn old-cache)
  710.         (cache-mask cache) cache-mask
  711.         (cache-size cache) actual-size
  712.         (cache-line-size cache) line-size
  713.         (cache-max-location cache)
  714.               (the index (let ((line (1- nlines)))
  715.                             (declare (type index line))
  716.                 (if (= nkeys 1)
  717.                     (the index (* line line-size))
  718.                     (the index (1+ (the index (* line line-size)))))))
  719.         (cache-vector cache) (get-cache-vector actual-size)
  720.         (cache-overflow cache) nil)
  721.       cache)))
  722.  
  723. (defun copy-cache (old-cache)
  724.   (let* ((new-cache (copy-cache-internal old-cache))
  725.      (size (cache-size old-cache))
  726.      (old-vector (cache-vector old-cache))
  727.      (new-vector (get-cache-vector size)))
  728.     (declare (type simple-vector old-vector new-vector)
  729.              (type index         size))
  730.     (dotimes (i size)
  731.       (setf (svref new-vector i) (svref old-vector i)))
  732.     (setf (cache-vector new-cache) new-vector)
  733.     new-cache))
  734.  
  735. (defun free-cache (cache)
  736.   (free-cache-vector (cache-vector cache))
  737.   (setf (cache-vector cache) '#())
  738.   (push cache *free-caches*)
  739.   nil)
  740.  
  741.  
  742.        
  743.  
  744. (defun compute-line-size (x)
  745.   (declare (type index x))
  746.   (power-of-two-ceiling x))
  747.  
  748. (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
  749.   (declare (values cache-mask actual-size line-size nlines))
  750.   (declare (type index nkeys))
  751.   (if (= nkeys 1)
  752.       (let* ((line-size (if valuep 2 1))
  753.          (cache-size (if (typep nlines-or-cache-vector 'fixnum)
  754.                  (the index
  755.                   (* line-size
  756.                      (power-of-two-ceiling 
  757.                     (the index nlines-or-cache-vector))))
  758.                  (cache-vector-size nlines-or-cache-vector))))
  759.     (declare (type index line-size cache-size))
  760.     (values (logxor (the index (1- cache-size)) (the index (1- line-size)))
  761.         cache-size
  762.         line-size
  763.         (the index (floor cache-size line-size))))
  764.       (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
  765.          (cache-size (if (typep nlines-or-cache-vector 'fixnum)
  766.                  (the index
  767.                   (* line-size
  768.                      (the index
  769.                       (power-of-two-ceiling 
  770.                         nlines-or-cache-vector))))
  771.                  (1- (cache-vector-size nlines-or-cache-vector)))))
  772.     (declare (type index line-size cache-size))
  773.     (values (logxor (the index (1- cache-size)) (the index (1- line-size)))
  774.         (the index (1+ cache-size))
  775.         line-size
  776.         (the index (floor cache-size line-size))))))
  777.  
  778.  
  779.  
  780. ;;;
  781. ;;; The various implementations of computing a primary cache location from
  782. ;;; wrappers.  Because some implementations of this must run fast there are
  783. ;;; several implementations of the same algorithm.
  784. ;;;
  785. ;;; The algorithm is:
  786. ;;;
  787. ;;;  SUM       over the wrapper cache numbers,
  788. ;;;  ENSURING  that the result is a fixnum
  789. ;;;  MASK      the result against the mask argument.
  790. ;;;
  791. ;;;
  792.  
  793. ;;;
  794. ;;; COMPUTE-PRIMARY-CACHE-LOCATION
  795. ;;; 
  796. ;;; The basic functional version.  This is used by the cache miss code to
  797. ;;; compute the primary location of an entry.  
  798. ;;;
  799. (defun compute-primary-cache-location (field mask wrappers)
  800.   (declare (type field-type field) (type index mask))
  801.   (if (not (listp wrappers))
  802.       (the index
  803.           (logand mask (the index (wrapper-cache-number-vector-ref wrappers field))))
  804.       (let ((location 0) (i 0))
  805.     (declare (type index location i))
  806.     (dolist (wrapper wrappers)
  807.       ;;
  808.       ;; First add the cache number of this wrapper to location.
  809.       ;; 
  810.       (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper field)))
  811.         (declare (type index wrapper-cache-number))
  812.         (if (zerop wrapper-cache-number)
  813.         (return-from compute-primary-cache-location 0)
  814.         (setq location (the index (+ location wrapper-cache-number)))))
  815.       ;;
  816.       ;; Then, if we are working with lots of wrappers, deal with
  817.       ;; the wrapper-cache-number-mask stuff.
  818.       ;; 
  819.       (when (and (not (zerop i))
  820.              (zerop (mod i wrapper-cache-number-adds-ok)))
  821.         (setq location
  822.           (the index (logand location wrapper-cache-number-mask))))
  823.       (setf i (the index (1+ i))))
  824.     (the index (1+ (the index (logand mask location)))))))
  825.  
  826. ;;;
  827. ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
  828. ;;;
  829. ;;; This version is called on a cache line.  It fetches the wrappers from
  830. ;;; the cache line and determines the primary location.  Various parts of
  831. ;;; the cache filling code call this to determine whether it is appropriate
  832. ;;; to displace a given cache entry.
  833. ;;; 
  834. ;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
  835. ;;; invalid to suggest to its caller that it would be provident to blow away
  836. ;;; the cache line in question.
  837. ;;;
  838. (defun compute-primary-cache-location-from-location (field cache location)
  839.   (declare (type field-type field) (type index location))
  840.   (let ((result 0)
  841.     (cache-vector (cache-vector cache))
  842.     (mask (cache-mask cache))
  843.     (nkeys (cache-nkeys cache)))
  844.     (declare (type index result mask nkeys) (simple-vector cache-vector))
  845.     (dotimes (i nkeys)
  846.       (let* ((wrapper (cache-vector-ref cache-vector (+ i location)))
  847.          (wcn (wrapper-cache-number-vector-ref wrapper field)))
  848.     (declare (type index wcn))
  849.     (setq result (the index (+ result wcn))))
  850.       (when (and (not (zerop i))
  851.          (zerop (mod i wrapper-cache-number-adds-ok)))
  852.     (setq result (the index (logand result wrapper-cache-number-mask)))))
  853.     (if (= nkeys 1)
  854.     (logand mask result)
  855.     (the index (1+ (the index (logand mask result)))))))
  856.  
  857. (defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
  858.   (with-lap-registers ((mask index) 
  859.                #+structure-wrapper (cnv fixnum-vector))
  860.     (let ((field wrapper-cache-no))
  861.       (flatten-lap
  862.         (opcode :move (operand :cvar 'mask) mask)
  863.         (opcode :move (operand :cvar 'field) field)
  864.     #-structure-wrapper
  865.         (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
  866.     #+structure-wrapper
  867.     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
  868.     #+structure-wrapper
  869.     (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no)
  870.         (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
  871.  
  872. (defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
  873.   (with-lap-registers ((field index)
  874.                (mask index))
  875.     (let ((add-wrapper-cache-numbers
  876.        (flatten-lap
  877.         (gathering1 (flattening-lap)
  878.            (iterate ((wrapper (list-elements wrappers))
  879.              (i (interval :from 1)))
  880.          (gather1
  881.           (with-lap-registers ((wrapper-cache-no index)
  882.                        #+structure-wrapper (cnv fixnum-vector))
  883.             (flatten-lap
  884.              #-structure-wrapper
  885.              (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
  886.              #+structure-wrapper
  887.              (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
  888.              #+structure-wrapper
  889.              (opcode :move (emit-cache-number-vector-ref cnv field)
  890.                  wrapper-cache-no)
  891.              (opcode :izerop wrapper-cache-no miss-label)
  892.              (opcode :move (operand :i+ primary wrapper-cache-no) primary)
  893.              (when (zerop (the index (mod (the index i)
  894.                                                   wrapper-cache-number-adds-ok)))
  895.                (opcode :move (operand :ilogand primary mask) primary))))))))))
  896.       (flatten-lap
  897.        (opcode :move (operand :constant 0) primary)
  898.        (opcode :move (operand :cvar 'field) field)
  899.        (opcode :move (operand :cvar 'mask) mask)
  900.        add-wrapper-cache-numbers
  901.        (opcode :move (operand :ilogand primary mask) primary)
  902.        (opcode :move (operand :i1+ primary) primary)))))
  903.  
  904.  
  905.  
  906. ;;;
  907. ;;;  NIL              means nothing so far, no actual arg info has NILs
  908. ;;;                   in the metatype
  909. ;;;  CLASS            seen all sorts of metaclasses
  910. ;;;                   (specifically, more than one of the next 4 values)
  911. ;;;  T                means everything so far is the class T
  912. ;;;  STANDARD-CLASS   seen only standard classes
  913. ;;;  BUILT-IN-CLASS   seen only built in classes
  914. ;;;  STRUCTURE-CLASS  seen only structure classes
  915. ;;;  
  916. (defun raise-metatype (metatype new-specializer)
  917.   (let ((slot      (find-class 'slot-class))
  918.     (standard  (find-class 'standard-class))
  919.     (fsc       (find-class 'funcallable-standard-class))
  920.     (structure (find-class 'structure-class))
  921.     (built-in  (find-class 'built-in-class)))
  922.     (flet ((specializer->metatype (x)
  923.          (let ((meta-specializer 
  924.              (if (eq *boot-state* 'complete)
  925.              (class-of (specializer-class x))
  926.              (class-of x))))
  927.            (cond ((eq x *the-class-t*) t)
  928.              ((*subtypep meta-specializer standard)  'standard-instance)
  929.              ((*subtypep meta-specializer fsc)       'standard-instance)
  930.              ((*subtypep meta-specializer structure) 'structure-instance)
  931.              ((*subtypep meta-specializer built-in)  'built-in-instance)
  932.              ((*subtypep meta-specializer slot)      'slot-instance)
  933.              (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)."
  934.                    new-specializer meta-specializer))))))
  935.       ;;
  936.       ;; We implement the following table.  The notation is
  937.       ;; that X and Y are distinct meta specializer names.
  938.       ;; 
  939.       ;;   NIL    <anything>    ===>  <anything>
  940.       ;;    X      X            ===>      X
  941.       ;;    X      Y            ===>    CLASS
  942.       ;;    
  943.       (let ((new-metatype (specializer->metatype new-specializer)))
  944.     (cond ((eq new-metatype 'slot-instance) 'class)
  945.           ((null metatype) new-metatype)
  946.           ((eq metatype new-metatype) new-metatype)
  947.           (t 'class))))))
  948.  
  949.  
  950.  
  951. (defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
  952.   (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
  953.     (with-lap-registers ((arg t))
  954.       (ecase metatype
  955.     (standard-instance
  956.       (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
  957.         (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
  958.                 #+pcl-user-instances
  959.         (get-user-inst-wrapper (make-symbol "get-user-inst-wrapper")))
  960.         (flatten-lap
  961.           (opcode :move (operand :arg argument) arg)
  962.           (opcode :std-instance-p arg get-std-inst-wrapper)       ;is it a std wrapper?
  963.           (opcode :fsc-instance-p arg get-fsc-inst-wrapper)       ;is it a fsc wrapper?
  964.               #+pcl-user-instances
  965.           (opcode :user-instance-p arg get-user-inst-wrapper)  ;is it a user wrapper?
  966.           (opcode :go miss-label)
  967.               #+pcl-user-instances
  968.           (opcode :label get-user-inst-wrapper)
  969.               #+pcl-user-instances
  970.           (opcode :move (operand :user-wrapper arg) dest)       ;get user wrapper
  971.               #+pcl-user-instances
  972.           (and slot
  973.            (opcode :move (operand :user-slots arg) slot))
  974.               #+pcl-user-instances
  975.           (opcode :go exit-emit-fetch-wrapper)
  976.           (opcode :label get-fsc-inst-wrapper)
  977.           (opcode :move (operand :fsc-wrapper arg) dest)       ;get fsc wrapper
  978.           (and slot
  979.            (opcode :move (operand :fsc-slots arg) slot))
  980.           (opcode :go exit-emit-fetch-wrapper)
  981.           (opcode :label get-std-inst-wrapper)
  982.           (opcode :move (operand :std-wrapper arg) dest)       ;get std wrapper
  983.           (and slot
  984.            (opcode :move (operand :std-slots arg) slot))
  985.           (opcode :label exit-emit-fetch-wrapper))))
  986.     (class
  987.       (when slot (error "Can't do a slot reg for this metatype."))
  988.       (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
  989.         (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
  990.                 #+pcl-user-instances
  991.         (get-user-inst-wrapper (make-symbol "get-user-inst-wrapper")))
  992.         (flatten-lap
  993.           (opcode :move (operand :arg argument) arg)
  994.           (opcode :std-instance-p arg get-std-inst-wrapper)
  995.           (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
  996.               #+pcl-user-instances
  997.           (opcode :user-instance-p arg get-user-inst-wrapper)
  998.           (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
  999.           (opcode :go exit-emit-fetch-wrapper)
  1000.               #+pcl-user-instances
  1001.           (opcode :label get-user-inst-wrapper)
  1002.               #+pcl-user-instances
  1003.           (opcode :move (operand :user-wrapper arg) dest)
  1004.               #+pcl-user-instances
  1005.           (opcode :go exit-emit-fetch-wrapper)
  1006.           (opcode :label get-fsc-inst-wrapper)
  1007.           (opcode :move (operand :fsc-wrapper arg) dest)
  1008.           (opcode :go exit-emit-fetch-wrapper)
  1009.           (opcode :label get-std-inst-wrapper)
  1010.           (opcode :move (operand :std-wrapper arg) dest)
  1011.           (opcode :label exit-emit-fetch-wrapper))))
  1012.     ((built-in-instance structure-instance)
  1013.       (when slot (error "Can't do a slot reg for this metatype."))
  1014.       (let ()
  1015.         (flatten-lap
  1016.           (opcode :move (operand :arg argument) arg)
  1017.           (opcode :std-instance-p arg miss-label)
  1018.           (opcode :fsc-instance-p arg miss-label)
  1019.           (opcode :move (operand :built-in-or-structure-wrapper arg) dest))))))))
  1020.  
  1021.  
  1022. ;;;
  1023. ;;; Some support stuff for getting a hold of symbols that we need when
  1024. ;;; building the discriminator codes.  Its ok for these to be interned
  1025. ;;; symbols because we don't capture any user code in the scope in which
  1026. ;;; these symbols are bound.
  1027. ;;; 
  1028.  
  1029. (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
  1030.  
  1031. (defun dfun-arg-symbol (arg-number)
  1032.   (declare (type index arg-number))
  1033.   (or (nth arg-number (the list *dfun-arg-symbols*))
  1034.       (intern (format nil ".ARG~A." arg-number) *the-pcl-package*)))
  1035.  
  1036. (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
  1037.  
  1038. (defun slot-vector-symbol (arg-number)
  1039.   (declare (type index arg-number))
  1040.   (or (nth arg-number (the list *slot-vector-symbols*))
  1041.       (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*)))
  1042.  
  1043. (defun make-dfun-lambda-list (metatypes applyp)
  1044.   (gathering1 (collecting)
  1045.     (iterate ((i (interval :from 0))
  1046.           (s (list-elements metatypes)))
  1047.       (progn s)
  1048.       (gather1 (dfun-arg-symbol i)))
  1049.     (when applyp
  1050.       (gather1 '&rest)
  1051.       (gather1 '.dfun-rest-arg.))))
  1052.  
  1053. (defun make-dlap-lambda-list (metatypes applyp)
  1054.   (gathering1 (collecting)
  1055.     (iterate ((i (interval :from 0))
  1056.           (s (list-elements metatypes)))
  1057.       (progn s)
  1058.       (gather1 (dfun-arg-symbol i)))
  1059.     (when applyp
  1060.       (gather1 '&rest))))
  1061.  
  1062. (defun make-dfun-call (metatypes applyp fn-variable)
  1063.   (let ((required
  1064.       (gathering1 (collecting)
  1065.         (iterate ((i (interval :from 0))
  1066.               (s (list-elements metatypes)))
  1067.           (progn s)
  1068.           (gather1 (dfun-arg-symbol i))))))
  1069.     (if applyp
  1070.     `(method-function-apply   ,fn-variable ,@required .dfun-rest-arg.)
  1071.     `(method-function-funcall ,fn-variable ,@required))))
  1072.  
  1073.  
  1074. ;;;
  1075. ;;; Its too bad Common Lisp compilers freak out when you have a defun with
  1076. ;;; a lot of LABELS in it.  If I could do that I could make this code much
  1077. ;;; easier to read and work with.
  1078. ;;;
  1079. ;;; Ahh Scheme...
  1080. ;;; 
  1081. ;;; In the absence of that, the following little macro makes the code that
  1082. ;;; follows a little bit more reasonable.  I would like to add that having
  1083. ;;; to practically write my own compiler in order to get just this simple
  1084. ;;; thing is something of a drag.
  1085. ;;;
  1086. (eval-when (compile load eval)
  1087.  
  1088. (defvar *cache* nil)
  1089.  
  1090. (defconstant *local-cache-functions*
  1091.   '((cache () .cache.)
  1092.     (nkeys () (cache-nkeys .cache.))
  1093.     (line-size () (cache-line-size .cache.))
  1094.     (pcl-vector () (cache-vector .cache.))
  1095.     (valuep () (cache-valuep .cache.))
  1096.     (nlines () (cache-nlines .cache.))
  1097.     (max-location () (cache-max-location .cache.))
  1098.     (limit-fn () (cache-limit-fn .cache.))
  1099.     (size () (cache-size .cache.))
  1100.     (mask () (cache-mask .cache.))
  1101.     (field () (cache-field .cache.))
  1102.  
  1103.     ;;
  1104.     ;; Return T IFF this cache location is reserved.  The only time
  1105.     ;; this is true is for line number 0 of an nkeys=1 cache.  
  1106.     ;;
  1107.     (line-reserved-p (line)
  1108.       (declare (type index line))
  1109.       (and (= (nkeys) 1)
  1110.            (= line 0)))
  1111.     ;;
  1112.     (location-reserved-p (location)
  1113.       (declare (type index location))
  1114.       (and (= (nkeys) 1)
  1115.            (= location 0)))
  1116.     ;;
  1117.     ;; Given a line number, return the cache location.  This is the
  1118.     ;; value that is the second argument to cache-vector-ref.  Basically,
  1119.     ;; this deals with the offset of nkeys>1 caches and multiplies
  1120.     ;; by line size.  
  1121.     ;;       
  1122.     (line-location (line)
  1123.       (declare (type index line))
  1124.       (when (line-reserved-p line)
  1125.         (error "line is reserved"))
  1126.       (if (= (nkeys) 1)
  1127.       (the index (* line (line-size)))
  1128.       (the index (1+ (the index (* line (line-size)))))))
  1129.     ;;
  1130.     ;; Given a cache location, return the line.  This is the inverse
  1131.     ;; of LINE-LOCATION.
  1132.     ;;       
  1133.     (location-line (location)
  1134.       (declare (type index location))
  1135.       (if (= (nkeys) 1)
  1136.       (floor location (line-size))
  1137.       (floor (the index (1- location)) (line-size))))
  1138.     ;;
  1139.     ;; Given a line number, return the wrappers stored at that line.
  1140.     ;; As usual, if nkeys=1, this returns a single value.  Only when
  1141.     ;; nkeys>1 does it return a list.  An error is signalled if the
  1142.     ;; line is reserved.
  1143.     ;;
  1144.     (line-wrappers (line)
  1145.       (declare (type index line))
  1146.       (when (line-reserved-p line) (error "Line is reserved."))
  1147.       (location-wrappers (line-location line)))
  1148.     ;;
  1149.     (location-wrappers (location) ; avoid multiplies caused by line-location
  1150.       (declare (type index location))
  1151.       (if (= (nkeys) 1)
  1152.       (cache-vector-ref (pcl-vector) location)
  1153.       (let ((list (make-list (nkeys)))
  1154.         (pcl-vector (pcl-vector)))
  1155.         (declare (simple-vector pcl-vector))
  1156.         (dotimes (i (nkeys) list)
  1157.           (setf (nth i list) (cache-vector-ref pcl-vector (+ location i)))))))
  1158.     ;;
  1159.     ;; Given a line number, return true IFF the line's
  1160.     ;; wrappers are the same as wrappers.
  1161.     ;;
  1162.     (line-matches-wrappers-p (line wrappers)
  1163.       (declare (type index line))
  1164.       (and (not (line-reserved-p line))
  1165.            (location-matches-wrappers-p (line-location line) wrappers)))
  1166.     ;;
  1167.     (location-matches-wrappers-p (loc wrappers) ; must not be reserved
  1168.       (declare (type index loc))
  1169.       (let ((cache-vector (pcl-vector)))
  1170.     (declare (simple-vector cache-vector))
  1171.     (if (= (nkeys) 1)
  1172.         (eq wrappers (cache-vector-ref cache-vector loc))
  1173.         (dotimes (i (nkeys) t)
  1174.           (unless (eq (pop wrappers) (cache-vector-ref cache-vector (+ loc i)))
  1175.         (return nil))))))
  1176.     ;;
  1177.     ;; Given a line number, return the value stored at that line.
  1178.     ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
  1179.     ;; an error is signalled if the line is reserved.
  1180.     ;; 
  1181.     (line-value (line)
  1182.       (declare (type index line))
  1183.       (when (line-reserved-p line) (error "Line is reserved."))
  1184.       (location-value (line-location line)))
  1185.     ;;
  1186.     (location-value (loc)
  1187.       (declare (type index loc))
  1188.       (and (valuep)
  1189.            (cache-vector-ref (pcl-vector) (+ loc (nkeys)))))
  1190.     ;;
  1191.     ;; Given a line number, return true IFF that line has data in
  1192.     ;; it.  The state of the wrappers stored in the line is not
  1193.     ;; checked.  An error is signalled if line is reserved.
  1194.     (line-full-p (line)
  1195.       (when (line-reserved-p line) (error "Line is reserved."))
  1196.       (not (null (cache-vector-ref (pcl-vector) (line-location line)))))
  1197.     ;;
  1198.     ;; Given a line number, return true IFF the line is full and
  1199.     ;; there are no invalid wrappers in the line, and the line's
  1200.     ;; wrappers are different from wrappers.
  1201.     ;; An error is signalled if the line is reserved.
  1202.     ;;
  1203.     (line-valid-p (line wrappers)
  1204.       (declare (type index line))
  1205.       (when (line-reserved-p line) (error "Line is reserved."))
  1206.       (location-valid-p (line-location line) wrappers))
  1207.     ;;
  1208.     (location-valid-p (loc wrappers)
  1209.       (declare (type index loc))
  1210.       (let ((cache-vector (pcl-vector))
  1211.         (wrappers-mismatch-p (null wrappers)))
  1212.     (declare (simple-vector cache-vector))
  1213.     (dotimes (i (nkeys) wrappers-mismatch-p)
  1214.       (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
  1215.         (when (or (null wrapper)
  1216.               (invalid-wrapper-p wrapper))
  1217.           (return nil))
  1218.         (unless (and wrappers
  1219.              (eq wrapper
  1220.                  (if (consp wrappers) (pop wrappers) wrappers)))
  1221.           (setq wrappers-mismatch-p t))))))
  1222.     ;;
  1223.     ;; How many unreserved lines separate line-1 and line-2.
  1224.     ;;
  1225.     (line-separation (line-1 line-2)
  1226.      (declare (type index line-1 line-2))
  1227.      (let ((diff (the fixnum (- line-2 line-1))))
  1228.        (declare (type fixnum diff))
  1229.        (when (minusp diff)
  1230.      (setq diff (+ diff (nlines)))
  1231.      (when (line-reserved-p 0)
  1232.        (setq diff (1- diff))))
  1233.        diff))
  1234.     ;;
  1235.     ;; Given a cache line, get the next cache line.  This will not
  1236.     ;; return a reserved line.
  1237.     ;; 
  1238.     (next-line (line)
  1239.      (declare (type index line))
  1240.      (if (= line (the index (1- (nlines))))
  1241.      (if (line-reserved-p 0) 1 0)
  1242.      (the index (1+ line))))
  1243.     ;;
  1244.     (next-location (loc)
  1245.       (declare (type index loc))
  1246.       (if (= loc (max-location))
  1247.       (if (= (nkeys) 1)
  1248.           (line-size)
  1249.           1)
  1250.       (the index (+ loc (line-size)))))
  1251.     ;;
  1252.     ;; Given a line which has a valid entry in it, this will return
  1253.     ;; the primary cache line of the wrappers in that line.  We just
  1254.     ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
  1255.     ;; easier packaging up of the call to it.
  1256.     ;; 
  1257.     (line-primary (field line)
  1258.       (declare (type index field line))
  1259.       (location-line (line-primary-location field line)))
  1260.     ;;
  1261.     (line-primary-location (field line)
  1262.      (declare (type index field line))
  1263.      (compute-primary-cache-location-from-location
  1264.        field (cache) (line-location line)))
  1265.     ))
  1266. ) ;eval-when
  1267.  
  1268. (eval-when (compile load eval)
  1269. (defmacro with-local-cache-functions ((cache) &body body)
  1270.   `(let ((.cache. ,cache))
  1271.      (declare (type cache .cache.))
  1272.      (macrolet ,(mapcar #'(lambda (fn)
  1273.                 `(,(car fn) ,(cadr fn)
  1274.                     `(let (,,@(mapcar #'(lambda (var)
  1275.                               ``(,',var ,,var))
  1276.                               (cadr fn)))
  1277.                     ,@',(cddr fn))))
  1278.             *local-cache-functions*)
  1279.        ,@body)))
  1280. ) ;eval-when
  1281.  
  1282.  
  1283. ;;;
  1284. ;;; Here is where we actually fill, recache and expand caches.
  1285. ;;;
  1286. ;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external
  1287. ;;; entrypoints into this code.
  1288. ;;;
  1289. ;;; FILL-CACHE returns 1 value: a new cache
  1290. ;;;
  1291. ;;;   a wrapper field number
  1292. ;;;   a cache
  1293. ;;;   a mask
  1294. ;;;   an absolute cache size (the size of the actual vector)
  1295. ;;; It tries to re-adjust the cache every time it makes a new fill.  The
  1296. ;;; intuition here is that we want uniformity in the number of probes needed to
  1297. ;;; find an entry.  Furthermore, adjusting has the nice property of throwing out
  1298. ;;; any entries that are invalid.
  1299. ;;;
  1300. (defvar *cache-expand-threshold* 1.25)
  1301.  
  1302. (defun cache-count (cache)
  1303.   (with-local-cache-functions (cache)
  1304.     (let ((count 0)(location (if (= (nkeys) 1) (line-size) 1)))
  1305.       (declare (type index count))
  1306.       (dotimes (i (nlines) count)
  1307.     (unless (or (location-reserved-p location)
  1308.             (not (location-valid-p location nil)))
  1309.       (setq count (the index (1+ count))))
  1310.     (setq location (next-location location))))))
  1311.  
  1312. #|
  1313. (defun entry-in-cache-p (cache wrappers value)
  1314.   (declare (ignore value))
  1315.   (with-local-cache-functions (cache)
  1316.     (dotimes (i (nlines))
  1317.       (unless (line-reserved-p i)
  1318.     (when (equal (line-wrappers i) wrappers)
  1319.       (return t))))))
  1320. |#
  1321.  
  1322. (defun fill-cache (cache wrappers value &optional free-cache-p)
  1323.   (declare (values cache))
  1324.   (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check.
  1325.     (error "fill-cache: wrappers arg is NIL!"))
  1326.   (or (fill-cache-p nil cache wrappers value)
  1327.       (and (< (the index (ceiling (* (cache-count cache) 1.25)))
  1328.           (the index
  1329.                    (if (= (cache-nkeys cache) 1)
  1330.                (1- (cache-nlines cache))
  1331.                (cache-nlines cache))))
  1332.        (adjust-cache cache wrappers value free-cache-p))
  1333.       (expand-cache cache wrappers value free-cache-p)))
  1334.  
  1335. (defun probe-cache (cache wrappers &optional default)
  1336.   (declare (values value))
  1337.   (unless wrappers (error "probe-cache: wrappers arg is NIL!"))
  1338.   (with-local-cache-functions (cache)
  1339.     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
  1340.        (limit (funcall-function (limit-fn) (nlines))))
  1341.       (declare (type index location limit))
  1342.       (when (location-reserved-p location)
  1343.     (setq location (next-location location)))
  1344.       (dotimes (i limit default)
  1345.     (when (location-matches-wrappers-p location wrappers)
  1346.       (return (or (not (valuep)) (location-value location))))
  1347.     (setq location (next-location location))))))
  1348.  
  1349. (defun map-cache (function cache &optional set-p)
  1350.   (declare (type real-function function))
  1351.   (with-local-cache-functions (cache)
  1352.     (let ((set-p (and set-p (valuep))))
  1353.       (dotimes (i (nlines) cache)
  1354.     (unless (or (line-reserved-p i) (not (line-valid-p i nil)))
  1355.       (let ((value (funcall function (line-wrappers i) (line-value i))))
  1356.         (when set-p
  1357.           (setf (cache-vector-ref (pcl-vector) (+ (line-location i) (nkeys)))
  1358.             value))))))))
  1359.  
  1360.  
  1361. ;;;
  1362. ;;; returns T or NIL
  1363. ;;;
  1364.  
  1365. (defun fill-cache-p (forcep cache wrappers value)
  1366.   (with-local-cache-functions (cache)
  1367.     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
  1368.        (primary (location-line location)))
  1369.       (declare (type index location primary))
  1370.       (multiple-value-bind (free emptyp)
  1371.       (find-free-cache-line primary cache wrappers)
  1372.     (when (or forcep emptyp)
  1373.       (when (not emptyp)
  1374.         (push (cons (line-wrappers free) (line-value free)) 
  1375.           (cache-overflow cache)))
  1376.       ;;(fill-line free wrappers value)
  1377.       (let ((line free))
  1378.         (declare (type index line))
  1379.         (when (line-reserved-p line)
  1380.           (error "Attempt to fill a reserved line."))
  1381.         (let ((loc (line-location line))
  1382.           (cache-vector (pcl-vector)))
  1383.           (declare (type index loc) (simple-vector cache-vector))
  1384.           (cond ((= (nkeys) 1)
  1385.              (setf (cache-vector-ref cache-vector loc) wrappers)
  1386.              (when (valuep)
  1387.                (setf (cache-vector-ref cache-vector (1+ loc)) value)))
  1388.             (t
  1389.              (let ((i 0))
  1390.                (declare (type index i))
  1391.                (dolist (w wrappers)
  1392.              (setf (cache-vector-ref cache-vector (+ loc i)) w)
  1393.              (setq i (the index (1+ i)))))
  1394.              (when (valuep)
  1395.                (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
  1396.                  value))))))
  1397.       cache)))))
  1398.  
  1399. (defun fill-cache-from-cache-p (forcep cache from-cache from-line)
  1400.   (declare (type index from-line))
  1401.   (with-local-cache-functions (from-cache)
  1402.     (let ((primary (line-primary (field) from-line)))
  1403.       (declare (type index primary))
  1404.       (multiple-value-bind (free emptyp)
  1405.       (find-free-cache-line primary cache)
  1406.     (when (or forcep emptyp)
  1407.       (when (not emptyp)
  1408.         (push (cons (line-wrappers free) (line-value free))
  1409.           (cache-overflow cache)))
  1410.       ;;(transfer-line from-cache-vector from-line cache-vector free)
  1411.       (let ((from-cache-vector (pcl-vector))
  1412.         (to-cache-vector (cache-vector cache))
  1413.         (to-line free))
  1414.         (declare (type index to-line))
  1415.         (if (line-reserved-p to-line)
  1416.         (error "transfering something into a reserved cache line.")
  1417.         (let ((from-loc (line-location from-line))
  1418.               (to-loc (line-location to-line)))
  1419.           (declare (type index from-loc to-loc))
  1420.           (modify-cache to-cache-vector
  1421.                 (dotimes (i (line-size))
  1422.                   (setf (cache-vector-ref to-cache-vector
  1423.                               (+ to-loc i))
  1424.                     (cache-vector-ref from-cache-vector
  1425.                               (+ from-loc i))))))))
  1426.       cache)))))
  1427.  
  1428. ;;;
  1429. ;;; Returns NIL or (values <field> <cache>)
  1430. ;;; 
  1431. ;;; This is only called when it isn't possible to put the entry in the cache
  1432. ;;; the easy way.  That is, this function assumes that FILL-CACHE-P has been
  1433. ;;; called as returned NIL.
  1434. ;;;
  1435. ;;; If this returns NIL, it means that it wasn't possible to find a wrapper
  1436. ;;; field for which all of the entries could be put in the cache (within the
  1437. ;;; limit).  
  1438. ;;;
  1439. (defun adjust-cache (cache wrappers value free-old-cache-p)
  1440.   (with-local-cache-functions (cache)
  1441.     (let ((ncache (get-cache-from-cache cache (nlines) (field))))
  1442.       (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield)))
  1443.       ((null nfield) (free-cache ncache) nil)
  1444.     (setf (cache-field ncache) (the index nfield))
  1445.     (labels ((try-one-fill-from-line (line)
  1446.            (fill-cache-from-cache-p nil ncache cache line))
  1447.          (try-one-fill (wrappers value)
  1448.            (fill-cache-p nil ncache wrappers value)))
  1449.       (if (and (dotimes (i (nlines) t)
  1450.              (when (and (null (line-reserved-p i))
  1451.                 (line-valid-p i wrappers))
  1452.                (unless (try-one-fill-from-line i) (return nil))))
  1453.            (dolist (wrappers+value (cache-overflow cache) t)
  1454.              (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
  1455.                (return nil)))
  1456.            (try-one-fill wrappers value))
  1457.           (progn (when free-old-cache-p (free-cache cache))
  1458.              (return ncache))
  1459.           (flush-cache-vector-internal (cache-vector ncache))))))))
  1460.  
  1461.                
  1462. ;;;
  1463. ;;; returns: (values <cache>)
  1464. ;;;
  1465. (defun expand-cache (cache wrappers value free-old-cache-p)
  1466.   (declare (values cache))
  1467.   (with-local-cache-functions (cache)
  1468.     (let ((ncache (get-cache-from-cache cache (the index (* (nlines) 2)))))
  1469.       (labels ((do-one-fill-from-line (line)
  1470.          (unless (fill-cache-from-cache-p nil ncache cache line)
  1471.            (do-one-fill (line-wrappers line) (line-value line))))
  1472.            (do-one-fill (wrappers value)
  1473.          (setq ncache (or (adjust-cache ncache wrappers value t)
  1474.                   (fill-cache-p t ncache wrappers value))))
  1475.            (try-one-fill (wrappers value)
  1476.          (fill-cache-p nil ncache wrappers value)))
  1477.     (dotimes (i (nlines))
  1478.       (when (and (null (line-reserved-p i))
  1479.              (line-valid-p i wrappers))
  1480.         (do-one-fill-from-line i)))
  1481.     (dolist (wrappers+value (cache-overflow cache))
  1482.       (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
  1483.         (do-one-fill (car wrappers+value) (cdr wrappers+value))))
  1484.     (unless (try-one-fill wrappers value)
  1485.       (do-one-fill wrappers value))
  1486.     (when free-old-cache-p (free-cache cache))
  1487.     ncache))))
  1488.  
  1489.  
  1490. ;;;
  1491. ;;; This is the heart of the cache filling mechanism.  It implements the decisions
  1492. ;;; about where entries are placed.
  1493. ;;; 
  1494. ;;; Find a line in the cache at which a new entry can be inserted.
  1495. ;;;
  1496. ;;;   <line>
  1497. ;;;   <empty?>           is <line> in fact empty?
  1498. ;;;
  1499. (defun find-free-cache-line (primary cache &optional wrappers)
  1500.   (declare (values line empty?))
  1501.   (declare (type index primary))
  1502.   (with-local-cache-functions (cache)
  1503.     (when (line-reserved-p primary) (setq primary (next-line primary)))
  1504.     (let ((limit (funcall-function (limit-fn) (nlines)))
  1505.       (field (field))
  1506.       (wrappedp nil)
  1507.       (lines nil)
  1508.       (p primary) (s primary)
  1509.       (successp nil))
  1510.       (declare (type index p s limit) (type field-type field)
  1511.                (type boolean wrappedp successp))
  1512.       (block find-free
  1513.     (loop
  1514.      ;; Try to find a free line starting at <s>.  <p> is the
  1515.      ;; primary line of the entry we are finding a free
  1516.      ;; line for, it is used to compute the seperations.
  1517.      (do* ((line s (next-line line))
  1518.            (nsep (line-separation p s) (the index (1+ nsep))))
  1519.           (())
  1520.        (declare (type index line nsep))
  1521.        (when (null (line-valid-p line wrappers)) ;If this line is empty or
  1522.          (push line lines)        ;invalid, just use it.
  1523.          (return-from find-free (setq successp t)))
  1524.        (let ((osep (line-separation (line-primary field line) line)))
  1525.          (when (and wrappedp (>= line primary))
  1526.            ;; have gone all the way around the cache, time to quit
  1527.            (push line lines)
  1528.            (return-from find-free (setq successp nil)))
  1529.          (when (cond ((= nsep limit) t)
  1530.              ((= nsep osep) (zerop (the index (random 2))))
  1531.              ((> nsep osep) t)
  1532.              (t nil))
  1533.            ;; See if we can displace what is in this line so that we
  1534.            ;; can use the line.
  1535.            (when (= line (the index (1- (nlines)))) (setq wrappedp t))
  1536.            (setq p (line-primary field line))
  1537.            (setq s (next-line line))
  1538.            (push line lines)
  1539.            (return nil)))
  1540.        (when (= line (the index (1- (nlines)))) (setq wrappedp t)))))
  1541.       ;; Do all the displacing.
  1542.       (loop 
  1543.        (when (null (cdr lines)) (return nil))
  1544.        (let ((dline (pop lines))
  1545.          (line (car lines)))
  1546.      (declare (type index dline line))
  1547.      (when successp
  1548.        ;;Copy from line to dline (dline is known to be free).
  1549.        (let ((from-loc (line-location line))
  1550.          (to-loc (line-location dline))
  1551.          (cache-vector (pcl-vector)))
  1552.          (declare (type index from-loc to-loc) (simple-vector cache-vector))
  1553.          (modify-cache cache-vector
  1554.                (dotimes (i (line-size))
  1555.                  (setf (cache-vector-ref cache-vector (+ to-loc i))
  1556.                    (cache-vector-ref cache-vector (+ from-loc i)))
  1557.                  (setf (cache-vector-ref cache-vector (+ from-loc i))
  1558.                    nil)))))))
  1559.       (values (car lines) successp))))
  1560.  
  1561. (defun default-limit-fn (nlines)
  1562.   (declare (type index nlines))
  1563.   (case nlines
  1564.     ((1 2 4) 1)
  1565.     ((8 16)  4)
  1566.     (otherwise 6)))
  1567.  
  1568. #-*lisp-simulator
  1569. (declaim (type cache *empty-cache*))
  1570. (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
  1571.  
  1572.  
  1573.  
  1574. ;;;
  1575. ;;; pre-allocate generic function caches.  The hope is that this will put
  1576. ;;; them nicely together in memory, and that that may be a win.  Of course
  1577. ;;; the first gc copy will probably blow that out, this really wants to be
  1578. ;;; wrapped in something that declares the area static.
  1579. ;;;
  1580. ;;; This preallocation only creates about 25% more caches than PCL itself
  1581. ;;; uses.  Some ports may want to preallocate some more of these.
  1582. ;;; 
  1583. (eval-when (load)
  1584.   (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32)
  1585.             (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2)))
  1586.     (let ((n (car n-size))
  1587.       (size (cadr n-size)))
  1588.       (mapcar #'free-cache-vector
  1589.           (mapcar #'get-cache-vector
  1590.               (make-list n :initial-element size))))))
  1591.  
  1592. (defun caches-to-allocate ()
  1593.   (sort (let ((l nil))
  1594.       (maphash #'(lambda (size entry)
  1595.                (push (list (car entry) size) l))
  1596.            pcl::*free-caches*)
  1597.       l)
  1598.     #'> :key #'cadr))
  1599.  
  1600.  
  1601.